perm filename LISS.F4[JC,MUS] blob
sn#017004 filedate 1972-12-20 generic text, type T, neo UTF8
SUBROUTINE SPACE4(AMP,RAMP,DOP,CHNA,CHNB,CHNC,CHND,ARRAY)
DIMENSION AMP(512),RAMP(512),DOP(512),
1 CHNA(512),CHNB(512),CHNC(512),CHND(512)
DIMENSION F(7),G(3)
DIMENSION ARRAY(2,600),B(4),C(3),D(4),E(7)
DIMENSION ST(50),SU(350)
DATA (B(I),I=1,3)/'A TO B IN FT.'/
DATA (C(I),I=1,3)/'LISS=1,LINE=2'/
DATA (D(I),I=1,3)/'0=FIN,1=REDEF'/
DATA (E(I),I=1,6)/'SEE AMP=1,DOP=2,STER1=3 OR 0'/
DATA (F(I),I=1,6)/'X,Y,RAD OR X1,Y1,X2,Y2,X3,Y3'/
DATA (G(I),I=1,2)/'CYCL TM='/
CALL TYPLOC(-300,-512)
101 CONTINUE
C CALL CLEAR
CALL DPYSET(1,ST,50)
CALL DPYBRT(1)
CALL AIVECT(0,0)
CALL HYDPOG(1)
IF(KT1.EQ.1)KT1=513
IY=100
DO 11 I=1,2
CALL ALINE(-100,IY,100,IY)
11 IY=-IY
IX=100
DO 12 I=1,2
CALL ALINE(IX,-100,IX,100)
12 IX=-IX
CALL ALINE(0,0,0,100)
CALL DPYOUT(1)
CC SPACE DEFINITION FINISHED
CALL MESS(B)
CALL RDNUM(DIS)
DELTA=DIS/100.0
CALL MESS(C)
CALL RDNUM(XNUM)
IF(XNUM.EQ.0.0)GO TO 20
L=XNUM
CALL DPYSET(2,SU,350)
CALL DPYBRT(6)
CALL AIVECT(0,0)
CALL MESS(F)
GO TO (1,2,2),L
1 CALL RDNUM(XCO)
CALL RDNUM(YCO)
CALL RDNUM(RADIUS)
RADNS=(2.0*3.1415927)/512.0
CRADNS=RADNS
IL=1
36 CONTINUE
SINR=SIN(CRADNS)
COSR=COS(CRADNS)
CRADNS=CRADNS+RADNS
ARRAY(1,IL)=SINR*RADIUS+XCO
ARRAY(2,IL)=COSR*RADIUS+YCO
GO TO 520
2 CALL RDNUM(XCO1)
CALL RDNUM(YCO1)
CALL RDNUM(FREQX)
CALL RDNUM(PHASX)
CALL RDNUM(FREQY)
CALL RDNUM(PHASY)
CALL RDNUM(FREQ2X)
CALL RDNUM(PHAS2X)
CALL RDNUM(FREQ2Y)
CALL RDNUM(PHAS2Y)
CALL RDNUM(DIA)
CALL RDNUM(DIA2)
IF(L.EQ.3)GOTO 3
XINC=(FREQX*360.)/512.
XINC2=(FREQ2X*360.)/512.
XK=-XINC+PHASX
XK2=-XINC2+PHAS2X
YINC=(FREQY*360.)/512.
YINC2=(FREQ2Y*360.)/512.
YK=-YINC+PHASY
YK2=-YINC2+PHAS2Y
IL=1
37 CONTINUE
XX=XK+XINC
XX2=XK2+XINC2
IF(XX.GE.360.)XX=XX-360.
IF(XX2.GE.360.)XX2=XX2-360.
XK=XX
XK2=XX2
YY=YK+YINC
YY2=YK2+YINC2
IF(YY.GE.360.)YY=YY-360.
IF(YY2.GE.360.)YY2=YY2-360.
YK=YY
YK2=YY2
ARRAY(1,IL)=XCO1+SIND(XX)*DIA+(SIND(XX2)*DIA2)
ARRAY(2,IL)=YCO1+SIND(YY)*DIA+(SIND(YY2)*DIA2)
GO TO 520
3 CALL RDNUM(XCO3)
CALL RDNUM(YCO3)
XDIF1=XCO2-XCO1
XDIF2=XCO3-XCO2
YDIF1=YCO2-YCO1
YDIF2=YCO3-YCO2
XCO4=XCO2+XDIF2-XDIF1
YCO4=YCO2+YDIF2-YDIF1
XCOI1=XDIF1/128.
XCOI2=XDIF2/128.
YCOI1=YDIF1/128.
YCOI2=YDIF2/128.
C XCO1=XCO1-XCOI1
C YCO1=YCO1-YCOI1
IL=1
32 IF(IL.GT.128)GO TO 33
ARRAY(1,IL)=XCO1+XCOI1
ARRAY(2,IL)=YCO1+YCOI1
XCO1=ARRAY(1,IL)
YCO1=ARRAY(2,IL)
GO TO 520
33 IF(IL.GT.256.)GO TO 34
ARRAY(1,IL)=XCO2+XCOI2
ARRAY(2,IL)=YCO2+YCOI2
XCO2=ARRAY(1,IL)
YCO2=ARRAY(2,IL)
GO TO 520
34 IF(IL.GT.384)GO TO 35
ARRAY(1,IL)=XCO3-XCOI1
ARRAY(2,IL)=YCO3-YCOI1
XCO3=ARRAY(1,IL)
YCO3=ARRAY(2,IL)
GO TO 520
35 ARRAY(1,IL)=XCO4-XCOI2
ARRAY(2,IL)=YCO4-YCOI2
XCO4=ARRAY(1,IL)
YCO4=ARRAY(2,IL)
520 NEWX=ARRAY(1,IL)
NEWY=ARRAY(2,IL)
IF(IL.GT.1)GO TO 503
CALL AIVECT(NEWX,NEWY)
GO TO 504
503 CALL SVECT(NEWX-IOLDX,NEWY-IOLDY)
504 IOLDX=NEWX
IOLDY=NEWY
CALL DPYOUT(2)
IL=IL+1
IF(IL.GT.512)GO TO 500
GO TO (36,37,32),L
500 CONTINUE
M=512
CALL MESS(G)
CALL RDNUM(SPD1)
SPD1=60.0/((1.0/SPD1)*512.0)
GO TO 501
20 SPD1=SPD
C CALL POS(ARRAY,600,M,SPD1)
501 X=M-1
AI=X/512.0
BI=2.0
S=60.0/SPD1
R=SQRT(ARRAY(1,1)**2+ARRAY(2,1)**2)
DO 100 J=1,512
I=BI
X=ARRAY(1,I)
Y=ARRAY(2,I)
BI=BI+AI
R1=SQRT(X**2+Y**2)
AMP(J)=DIS/(R1*DELTA)
RAMP(J)=ALOG(DIS)/ALOG(R1*DELTA)
IF(RAMP(J).GT.1.)RAMP(J)=1.
CONTINUE
VR=S*DELTA*(R1-R)
XJ=J
IF((R1.EQ.R).AND.(XJ.GT.1.0))GO TO 31
DOP(J)=1180.0/(1180.0+VR)
GO TO 21
31 DOP(J)=DOP(J-1)
21 R=R1
CONTINUE
AX=ABS(X)
AY=ABS(Y)
PI=3.1416
ANGLE=AMOD(ATAN2(Y,X)+6.2832,6.2832)
PI2=PI/2.0
IF((AX.LE.AY).AND.(Y.GT.0.0))GO TO 2000
IF((AX.GT.AY).AND.(X.GT.0.0))GO TO 2001
IF((AX.LE.AY).AND.(Y.LT.0.0))GO TO 2002
CHN=ANGLE-(3.*PI)/4.
CHNB(J)=1.-CHN/PI2
CHNC(J)=CHN/PI2
CHNA(J)=0.0
CHND(J)=0.0
GO TO 100
2000 CHN=ANGLE-PI/4.
CHNA(J)=1.-CHN/PI2
CHNB(J)=CHN/PI2
CHNC(J)=0.0
CHND(J)=0.0
GO TO 100
2001 CHN=ANGLE-(7.*PI)/4.
IF(ANGLE.LT.PI/4.)CHN=ANGLE+PI/4.
CHND(J)=1.-CHN/PI2
CHNA(J)=CHN/PI2
CHNB(J)=0.0
CHNC(J)=0.0
GO TO 100
2002 CHN=ANGLE-(5.*PI)/4.
CHNC(J)=1.-CHN/PI2
CHND(J)=CHN/PI2
CHNA(J)=0.0
CHNB(J)=0.0
100 CONTINUE
DO 402 JK=1,512
CHNA(JK)=SQRT(CHNA(JK))
CHNB(JK)=SQRT(CHNB(JK))
CHNC(JK)=SQRT(CHNC(JK))
CHND(JK)=SQRT(CHND(JK))
402 CONTINUE
CALL INTERP(AMP)
CALL INTERP(RAMP)
CALL INTERP(DOP)
C CALL INTERP(CHNA)
C CALL INTERP(CHNB)
C CALL INTERP(CHNC)
C CALL INTERP(CHND)
801 CONTINUE
GO TO 937
99 CONTINUE
937 CALL MESS(E)
CALL RDNUM(X)
L=X
IF(L.EQ.0)GO TO 200
IF(L.GT.3)GO TO 937
CALL HYDPOG(1)
CALL HYDPOG(2)
C CALL CLEAR
CALL DPYSET(1,ST,50)
CALL DPYBRT(1)
CALL AIVECT(0,0)
IF(L.EQ.3)GO TO 203
CALL ALINE(-264,0,256,0)
CALL ALINE(-256,-256,-256,256)
CALL DPYOUT(1)
CALL DPYSET(2,SU,350)
CALL DPYBRT(6)
CALL AIVECT(0,0)
GO TO(201,202),L
201 IY=AMP(1)*256.
CALL AIVECT(-256,IY)
DO 301 I=2,512
IY2=AMP(I)*256.0
CALL SVECT(1,IY2-IY)
IY=IY2
301 CALL DPYOUT(2)
GO TO 99
202 IY=DOP(1)*256.-256.
CALL AIVECT(-256,IY)
DO 302 I=2,512
IY2=DOP(I)*256.0-256.
CALL SVECT(1,IY2-IY)
IY=IY2
302 CALL DPYOUT(2)
GO TO 99
203 CONTINUE
C CALL CLEAR
DO 300 J=-375,375,250
CALL AIVECT(0,J)
CALL RVECT(256,0)
CALL RIVECT(-256,-125)
CALL RVECT(0,250)
300 CALL DPYOUT(1)
CALL DPYSET(2,SU,350)
CALL DPYBRT(6)
CALL AIVECT(0,0)
IY=375
CALL DRAW(CHNA,IY)
IY=125
CALL DRAW(CHNB,IY)
IY=-125
CALL DRAW(CHNC,IY)
IY=-375
CALL DRAW(CHND,IY)
GO TO 99
200 CALL MESS(D)
CALL RDNUM(X)
IF(X.EQ.0.0)GO TO 307
CALL HYDPOG(2)
GO TO 101
307 CONTINUE
C CALL CLEAR
CALL DPYCLR
RETURN
END
CC******WAVE DRAWER**********************************************
SUBROUTINE DRAW(FUNC,ICT)
DIMENSION FUNC(512)
CALL AIVECT(0,ICT)
DO 100 I=1,512,4
IY2=FUNC(I)*125.
IF(I.GT.1)GO TO 10
CALL RIVECT(0,IY2)
GO TO 101
10 CALL SVECT(2,IY2-IY)
101 IY=IY2
100 CALL DPYOUT(2)
RETURN
END
CC******WAVE SMOOTHER********************************************
SUBROUTINE INTERP(CFUNC)
DIMENSION CFUNC(512)
JT=0
DO 601 KT=2,512
IF(CFUNC(KT-1).NE.CFUNC(KT))GO TO 600
IF(JT.EQ.0)JT=KT-1
GO TO 601
600 IF(JT.EQ.0)GO TO 601
DIFF=CFUNC(KT)-CFUNC(JT)
DIV=KT-JT
ANS=DIFF/DIV
DO 602 LM=JT+1,KT-1
602 CFUNC(LM)=CFUNC(LM-1)+ANS
JT=0
601 CONTINUE
RETURN
END